home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue34 / alfresco / Ternary.pas < prev    next >
Pascal/Delphi Source File  |  1998-07-03  |  9KB  |  315 lines
  1. {*********************************************************}
  2. {* Ternary                                               *}
  3. {* Copyright (c) Julian M Bucknall 1998                  *}
  4. {* All rights reserved.                                  *}
  5. {*********************************************************}
  6. {* A ternary search tree class                           *}
  7. {*********************************************************}
  8.  
  9. {Note: this unit is released as freeware. In other words, you are free
  10.        to use this unit in your own applications, however I retain all
  11.        copyright to the code. JMB}
  12.  
  13. {$IFDEF VER80}
  14. !! Error
  15. This unit uses long strings only. In other words, you must be using
  16. Delphi 2 or later.
  17. {$ENDIF}
  18.  
  19. unit Ternary;
  20.  
  21. interface
  22.  
  23. uses
  24.   SysUtils;
  25.  
  26. type
  27.   PTSTNode = ^TTSTNode;
  28.   TTSTNode = record
  29.     Left, Equal, Right : PTSTNode;
  30.     EqualChar : char;
  31.     NullInUse : boolean;
  32.   end;
  33.  
  34. type
  35.   TTSTActionProc = procedure(const S : string; Data : pointer);
  36.  
  37. type
  38.   TTernaryTree = class
  39.     {-a ternary search tree}
  40.     protected {private}
  41.       FCount      : integer;
  42.       FIgnoreCase : boolean;
  43.       FRoot       : PTSTNode;
  44.     protected
  45.       procedure SetIgnoreCase(Value : boolean);
  46.     public
  47.       constructor Create;
  48.       destructor Destroy; override;
  49.  
  50.       procedure Insert(const S : string; aData : pointer);
  51.         {-insert a string with associated data}
  52.       procedure Delete(const S : string);
  53.         {-delete a string; associated data is not freed}
  54.       procedure Iterate(Action : TTSTActionProc);
  55.         {-iterate through all the strings, calling Action for each}
  56.       procedure PartialSearch(const S : string; Action : TTSTActionProc);
  57.         {-search for a pattern string, calling Action for all matches}
  58.       function Search(const S : string; var aData : pointer) : boolean;
  59.         {-search for a string}
  60.  
  61.       property Count : integer read FCount;
  62.         {-count of strings}
  63.       property IgnoreCase : boolean read FIgnoreCase write SetIgnoreCase;
  64.         {-make tree case-sensitive (false) or case-insensitive (true)}
  65.   end;
  66.  
  67. implementation
  68.  
  69. {===Recursives=======================================================}
  70. procedure DeleteAllNodesPrim(Node : PTSTNode);
  71. begin
  72.   if (Node = nil) then
  73.     Exit;
  74.   DeleteAllNodesPrim(Node^.Left);
  75.   if (Node^.EqualChar <> #0) then
  76.     DeleteAllNodesPrim(Node^.Equal);
  77.   DeleteAllNodesPrim(Node^.Right);
  78.   Dispose(Node);
  79. end;
  80. {--------}
  81. function DeletePrim(const S : string; Inx : integer; Node : PTSTNode) : boolean;
  82. begin
  83.   Result := false;
  84.   if (Node = nil) then
  85.     Exit;
  86.   with Node^ do begin
  87.     if (S[Inx] < EqualChar) then begin
  88.       if DeletePrim(S, Inx, Left) then
  89.         Left := nil
  90.     end
  91.     else if (S[Inx] > EqualChar) then begin
  92.       if DeletePrim(S, Inx, Right) then
  93.         Right := nil
  94.     end
  95.     else {they're equal} begin
  96.       if (EqualChar = #0) then begin
  97.         Equal := nil;
  98.         NullInUse := false;
  99.       end
  100.       else begin
  101.         inc(Inx);
  102.         if DeletePrim(S, Inx, Equal) then
  103.           Equal := nil;
  104.       end;
  105.     end;
  106.     if (Left = nil) and (Right = nil) and (Equal = nil) then begin
  107.       Dispose(Node);
  108.       Result := true;
  109.     end;
  110.   end;
  111. end;
  112. {--------}
  113. function InsertPrim(const S : string; aInx : integer;
  114.                     aData : pointer; aNode : PTSTNode) : PTSTNode;
  115. var
  116.   NewNode : boolean;
  117. begin
  118.   {if the passed node is nil, create a new one; note whether created}
  119.   if (aNode <> nil) then
  120.     NewNode := false
  121.   else {aNode is nil} begin
  122.     NewNode := true;
  123.     aNode := AllocMem(sizeof(TTSTNode));
  124.     aNode^.EqualChar := S[aInx];
  125.   end;
  126.   {if the current char is less than the equal char, go left}
  127.   if (S[aInx] < aNode^.EqualChar) then
  128.     aNode^.Left := InsertPrim(S, aInx, aData, aNode^.Left)
  129.   {if the current char is greater than the equal char, go right}
  130.   else if (S[aInx] > aNode^.EqualChar) then
  131.     aNode^.Right := InsertPrim(S, aInx, aData, aNode^.Right)
  132.   {otherwise the characters are equal}
  133.   else begin
  134.     {if the current char is non-null, increment current character,
  135.      follow equal link}
  136.     if (S[aInx] <> #0) then
  137.       aNode^.Equal := InsertPrim(S, succ(aInx), aData, aNode^.Equal)
  138.     {otherwise the current character is null: save the data pointer}
  139.     else {it's a null} begin
  140.       if (not NewNode) and aNode^.NullInUse then
  141.         raise Exception.Create('Insert: duplicate string');
  142.       aNode^.Equal := PTSTNode(aData);
  143.       aNode^.NullInUse := true;
  144.     end;
  145.   end;
  146.   {return the current node}
  147.   Result := aNode;
  148. end;
  149. {--------}
  150. procedure IteratePrim(var S : string; Action : TTSTActionProc; Node : PTSTNode);
  151. begin
  152.   {terminate the recursion, when required}
  153.   if (Node = nil) then
  154.     Exit;
  155.   {visit the left subtree}
  156.   IteratePrim(S, Action, Node^.Left);
  157.   {deal with the node character}
  158.   if (Node^.EqualChar = #0) and Node^.NullInUse then begin
  159.     Action(S, pointer(Node^.Equal));
  160.   end
  161.   else begin
  162.     {visit the equal subtree}
  163.     S := S + Node^.EqualChar;
  164.     IteratePrim(S, Action, Node^.Equal);
  165.     System.Delete(S, length(S), 1);
  166.   end;
  167.   {visit the right subtree}
  168.   IteratePrim(S, Action, Node^.Right);
  169. end;
  170. {--------}
  171. procedure PartialSearchPrim(const S      : string;
  172.                                   Inx    : integer;
  173.                                   Action : TTSTActionProc;
  174.                               var BuildS : string;
  175.                                   Node   : PTSTNode);
  176. begin
  177.   {terminate the recursion, when required}
  178.   if (Node = nil) then
  179.     Exit;
  180.   {visit the left subtree if either the current char is a '.' or it's
  181.    less than the equal char}
  182.   if (S[Inx] = '.') or (S[Inx] < Node^.EqualChar) then
  183.     PartialSearchPrim(S, Inx, Action, BuildS, Node^.Left);
  184.   {deal with the node character}
  185.   if (Node^.EqualChar = #0) and Node^.NullInUse and (S[Inx] = #0) then begin
  186.     Action(BuildS, pointer(Node^.Equal));
  187.   end
  188.   else begin
  189.     {visit the equal subtree if required}
  190.     if (S[Inx] = '.') or (S[Inx] = Node^.EqualChar) then
  191.       if (S[Inx] <> #0) and (Node^.EqualChar <> #0) then begin
  192.         BuildS := BuildS + Node^.EqualChar;
  193.         PartialSearchPrim(S, Inx+1, Action, BuildS, Node^.Equal);
  194.         System.Delete(BuildS, length(BuildS), 1);
  195.       end;
  196.   end;
  197.   {visit the right subtree if either the current char is a '.' or it's
  198.    greater than the equal char}
  199.   if (S[Inx] = '.') or (S[Inx] > Node^.EqualChar) then
  200.     PartialSearchPrim(S, Inx, Action, BuildS, Node^.Right);
  201. end;
  202. {--------}
  203. function SearchPrim(const S : string; var aData : pointer;
  204.                                           aNode : PTSTNode) : boolean;
  205. var
  206.   Inx     : integer;
  207.   CurChar : char;
  208. begin
  209.   Inx := 1;
  210.   CurChar := S[1];
  211.   while (aNode <> nil) do begin
  212.     with aNode^ do begin
  213.       if (CurChar < EqualChar) then
  214.         aNode := Left
  215.       else if (CurChar > EqualChar) then
  216.         aNode := Right
  217.       else {they're equal} begin
  218.         if (CurChar = #0) then begin
  219.           Result := NullInUse;
  220.           aData := pointer(Equal);
  221.           Exit;
  222.         end;
  223.         aNode := Equal;
  224.         inc(Inx);
  225.         CurChar := S[Inx];
  226.       end;
  227.     end;
  228.   end;
  229.   Result := false;
  230. end;
  231. {====================================================================}
  232.  
  233.  
  234. {===TTernaryTree=====================================================}
  235. constructor TTernaryTree.Create;
  236. begin
  237. end;
  238. {--------}
  239. destructor TTernaryTree.Destroy;
  240. begin
  241.   DeleteAllNodesPrim(FRoot);
  242. end;
  243. {--------}
  244. procedure TTernaryTree.Insert(const S : string; aData : pointer);
  245. var
  246.   WorkS  : string;
  247. begin
  248.   {prepare}
  249.   if IgnoreCase then
  250.     WorkS := AnsiLowerCase(S)
  251.   else
  252.     WorkS := S;
  253.   {insert}
  254.   FRoot := InsertPrim(WorkS, 1, aData, FRoot);
  255.   inc(FCount);
  256. end;
  257. {--------}
  258. procedure TTernaryTree.Delete(const S : string);
  259. var
  260.   Obj : pointer;
  261.   WorkS  : string;
  262. begin
  263.   if IgnoreCase then
  264.     WorkS := AnsiLowerCase(S)
  265.   else
  266.     WorkS := S;
  267.   if SearchPrim(WorkS, Obj, FRoot) then begin
  268.     if DeletePrim(WorkS, 1, FRoot) then
  269.       FRoot := nil;
  270.     dec(FCount);
  271.   end;
  272. end;
  273. {--------}
  274. procedure TTernaryTree.Iterate(Action : TTSTActionProc);
  275. var
  276.   S : string;
  277. begin
  278.   S := '';
  279.   IteratePrim(S, Action, FRoot);
  280. end;
  281. {--------}
  282. procedure TTernaryTree.PartialSearch(const S : string; Action : TTSTActionProc);
  283. var
  284.   BuildS : string;
  285.   WorkS  : string;
  286. begin
  287.   if IgnoreCase then
  288.     WorkS := AnsiLowerCase(S)
  289.   else
  290.     WorkS := S;
  291.   BuildS := '';
  292.   PartialSearchPrim(WorkS, 1, Action, BuildS, FRoot);
  293. end;
  294. {--------}
  295. function TTernaryTree.Search(const S : string; var aData : pointer) : boolean;
  296. var
  297.   WorkS   : string;
  298. begin
  299.   if IgnoreCase then
  300.     WorkS := AnsiLowerCase(S)
  301.   else
  302.     WorkS := S;
  303.   Result := SearchPrim(WorkS, aData, FRoot)
  304. end;
  305. {--------}
  306. procedure TTernaryTree.SetIgnoreCase(Value : boolean);
  307. begin
  308.   if (FCount > 0) then
  309.     raise Exception.Create('TTernaryTree.IgnoreCase can only be changed when empty');
  310.   FIgnoreCase := Value;
  311. end;
  312. {====================================================================}
  313.  
  314. end.
  315.